home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclPkg.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  20.8 KB  |  735 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclPkg.c --
  3.  *
  4.  *    This file implements package and version control for Tcl via
  5.  *    the "package" command and a few C APIs.
  6.  *
  7.  * Copyright (c) 1996 Sun Microsystems, Inc.
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  *
  12.  * SCCS: @(#) tclPkg.c 1.9 97/05/14 13:23:51
  13.  */
  14.  
  15. #include "tclInt.h"
  16.  
  17. /*
  18.  * Each invocation of the "package ifneeded" command creates a structure
  19.  * of the following type, which is used to load the package into the
  20.  * interpreter if it is requested with a "package require" command.
  21.  */
  22.  
  23. typedef struct PkgAvail {
  24.     char *version;        /* Version string; malloc'ed. */
  25.     char *script;        /* Script to invoke to provide this version
  26.                  * of the package.  Malloc'ed and protected
  27.                  * by Tcl_Preserve and Tcl_Release. */
  28.     struct PkgAvail *nextPtr;    /* Next in list of available versions of
  29.                  * the same package. */
  30. } PkgAvail;
  31.  
  32. /*
  33.  * For each package that is known in any way to an interpreter, there
  34.  * is one record of the following type.  These records are stored in
  35.  * the "packageTable" hash table in the interpreter, keyed by
  36.  * package name such as "Tk" (no version number).
  37.  */
  38.  
  39. typedef struct Package {
  40.     char *version;        /* Version that has been supplied in this
  41.                  * interpreter via "package provide"
  42.                  * (malloc'ed).  NULL means the package doesn't
  43.                  * exist in this interpreter yet. */
  44.     PkgAvail *availPtr;        /* First in list of all available versions
  45.                  * of this package. */
  46. } Package;
  47.  
  48. /*
  49.  * Prototypes for procedures defined in this file:
  50.  */
  51.  
  52. static int        CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
  53.                 char *string));
  54. static int        ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2,
  55.                 int *satPtr));
  56. static Package *    FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
  57.                 char *name));
  58.  
  59. /*
  60.  *----------------------------------------------------------------------
  61.  *
  62.  * Tcl_PkgProvide --
  63.  *
  64.  *    This procedure is invoked to declare that a particular version
  65.  *    of a particular package is now present in an interpreter.  There
  66.  *    must not be any other version of this package already
  67.  *    provided in the interpreter.
  68.  *
  69.  * Results:
  70.  *    Normally returns TCL_OK;  if there is already another version
  71.  *    of the package loaded then TCL_ERROR is returned and an error
  72.  *    message is left in interp->result.
  73.  *
  74.  * Side effects:
  75.  *    The interpreter remembers that this package is available,
  76.  *    so that no other version of the package may be provided for
  77.  *    the interpreter.
  78.  *
  79.  *----------------------------------------------------------------------
  80.  */
  81.  
  82. int
  83. Tcl_PkgProvide(interp, name, version)
  84.     Tcl_Interp *interp;        /* Interpreter in which package is now
  85.                  * available. */
  86.     char *name;            /* Name of package. */
  87.     char *version;        /* Version string for package. */
  88. {
  89.     Package *pkgPtr;
  90.  
  91.     pkgPtr = FindPackage(interp, name);
  92.     if (pkgPtr->version == NULL) {
  93.     pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
  94.     strcpy(pkgPtr->version, version);
  95.     return TCL_OK;
  96.     }
  97.     if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
  98.     return TCL_OK;
  99.     }
  100.     Tcl_AppendResult(interp, "conflicting versions provided for package \"",
  101.         name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL);
  102.     return TCL_ERROR;
  103. }
  104.  
  105. /*
  106.  *----------------------------------------------------------------------
  107.  *
  108.  * Tcl_PkgRequire --
  109.  *
  110.  *    This procedure is called by code that depends on a particular
  111.  *    version of a particular package.  If the package is not already
  112.  *    provided in the interpreter, this procedure invokes a Tcl script
  113.  *    to provide it.  If the package is already provided, this
  114.  *    procedure makes sure that the caller's needs don't conflict with
  115.  *    the version that is present.
  116.  *
  117.  * Results:
  118.  *    If successful, returns the version string for the currently
  119.  *    provided version of the package, which may be different from
  120.  *    the "version" argument.  If the caller's requirements
  121.  *    cannot be met (e.g. the version requested conflicts with
  122.  *    a currently provided version, or the required version cannot
  123.  *    be found, or the script to provide the required version
  124.  *    generates an error), NULL is returned and an error
  125.  *    message is left in interp->result.
  126.  *
  127.  * Side effects:
  128.  *    The script from some previous "package ifneeded" command may
  129.  *    be invoked to provide the package.
  130.  *
  131.  *----------------------------------------------------------------------
  132.  */
  133.  
  134. char *
  135. Tcl_PkgRequire(interp, name, version, exact)
  136.     Tcl_Interp *interp;        /* Interpreter in which package is now
  137.                  * available. */
  138.     char *name;            /* Name of desired package. */
  139.     char *version;        /* Version string for desired version;
  140.                  * NULL means use the latest version
  141.                  * available. */
  142.     int exact;            /* Non-zero means that only the particular
  143.                  * version given is acceptable. Zero means
  144.                  * use the latest compatible version. */
  145. {
  146.     Package *pkgPtr;
  147.     PkgAvail *availPtr, *bestPtr;
  148.     char *script;
  149.     int code, satisfies, result, pass;
  150.     Tcl_DString command;
  151.  
  152.     /*
  153.      * It can take up to three passes to find the package:  one pass to
  154.      * run the "package unknown" script, one to run the "package ifneeded"
  155.      * script for a specific version, and a final pass to lookup the
  156.      * package loaded by the "package ifneeded" script.
  157.      */
  158.  
  159.     for (pass = 1; ; pass++) {
  160.     pkgPtr = FindPackage(interp, name);
  161.     if (pkgPtr->version != NULL) {
  162.         break;
  163.     }
  164.  
  165.     /*
  166.      * The package isn't yet present.  Search the list of available
  167.      * versions and invoke the script for the best available version.
  168.      */
  169.     
  170.     bestPtr = NULL;
  171.     for (availPtr = pkgPtr->availPtr; availPtr != NULL;
  172.         availPtr = availPtr->nextPtr) {
  173.         if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
  174.             bestPtr->version, (int *) NULL) <= 0)) {
  175.         continue;
  176.         }
  177.         if (version != NULL) {
  178.         result = ComparePkgVersions(availPtr->version, version,
  179.             &satisfies);
  180.         if ((result != 0) && exact) {
  181.             continue;
  182.         }
  183.         if (!satisfies) {
  184.             continue;
  185.         }
  186.         }
  187.         bestPtr = availPtr;
  188.     }
  189.     if (bestPtr != NULL) {
  190.         /*
  191.          * We found an ifneeded script for the package.  Be careful while
  192.          * executing it:  this could cause reentrancy, so (a) protect the
  193.          * script itself from deletion and (b) don't assume that bestPtr
  194.          * will still exist when the script completes.
  195.          */
  196.     
  197.         script = bestPtr->script;
  198.         Tcl_Preserve((ClientData) script);
  199.         code = Tcl_GlobalEval(interp, script);
  200.         Tcl_Release((ClientData) script);
  201.         if (code != TCL_OK) {
  202.         if (code == TCL_ERROR) {
  203.             Tcl_AddErrorInfo(interp,
  204.                 "\n    (\"package ifneeded\" script)");
  205.         }
  206.         return NULL;
  207.         }
  208.         Tcl_ResetResult(interp);
  209.         pkgPtr = FindPackage(interp, name);
  210.         break;
  211.     }
  212.  
  213.     /*
  214.      * Package not in the database.  If there is a "package unknown"
  215.      * command, invoke it (but only on the first pass;  after that,
  216.      * we should not get here in the first place).
  217.      */
  218.  
  219.     if (pass > 1) {
  220.         break;
  221.     }
  222.     script = ((Interp *) interp)->packageUnknown;
  223.     if (script != NULL) {
  224.         Tcl_DStringInit(&command);
  225.         Tcl_DStringAppend(&command, script, -1);
  226.         Tcl_DStringAppendElement(&command, name);
  227.         Tcl_DStringAppend(&command, " ", 1);
  228.         Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
  229.             -1);
  230.         if (exact) {
  231.         Tcl_DStringAppend(&command, " -exact", 7);
  232.         }
  233.         code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command));
  234.         Tcl_DStringFree(&command);
  235.         if (code != TCL_OK) {
  236.         if (code == TCL_ERROR) {
  237.             Tcl_AddErrorInfo(interp,
  238.                 "\n    (\"package unknown\" script)");
  239.         }
  240.         return NULL;
  241.         }
  242.         Tcl_ResetResult(interp);
  243.     }
  244.     }
  245.  
  246.     if (pkgPtr->version == NULL) {
  247.     Tcl_AppendResult(interp, "can't find package ", name,
  248.         (char *) NULL);
  249.     if (version != NULL) {
  250.         Tcl_AppendResult(interp, " ", version, (char *) NULL);
  251.     }
  252.     return NULL;
  253.     }
  254.  
  255.     /*
  256.      * At this point we now that the package is present.  Make sure that the
  257.      * provided version meets the current requirement.
  258.      */
  259.  
  260.     if (version == NULL) {
  261.     return pkgPtr->version;
  262.     }
  263.     result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
  264.     if ((satisfies && !exact) || (result == 0)) {
  265.     return pkgPtr->version;
  266.     }
  267.     Tcl_AppendResult(interp, "version conflict for package \"",
  268.         name, "\": have ", pkgPtr->version, ", need ", version,
  269.         (char *) NULL);
  270.     return NULL;
  271. }
  272.  
  273. /*
  274.  *----------------------------------------------------------------------
  275.  *
  276.  * Tcl_PackageCmd --
  277.  *
  278.  *    This procedure is invoked to process the "package" Tcl command.
  279.  *    See the user documentation for details on what it does.
  280.  *
  281.  * Results:
  282.  *    A standard Tcl result.
  283.  *
  284.  * Side effects:
  285.  *    See the user documentation.
  286.  *
  287.  *----------------------------------------------------------------------
  288.  */
  289.  
  290.     /* ARGSUSED */
  291. int
  292. Tcl_PackageCmd(dummy, interp, argc, argv)
  293.     ClientData dummy;            /* Not used. */
  294.     Tcl_Interp *interp;            /* Current interpreter. */
  295.     int argc;                /* Number of arguments. */
  296.     char **argv;            /* Argument strings. */
  297. {
  298.     Interp *iPtr = (Interp *) interp;
  299.     size_t length;
  300.     int c, exact, i, satisfies;
  301.     PkgAvail *availPtr, *prevPtr;
  302.     Package *pkgPtr;
  303.     Tcl_HashEntry *hPtr;
  304.     Tcl_HashSearch search;
  305.     Tcl_HashTable *tablePtr;
  306.     char *version;
  307.     char buf[30];
  308.  
  309.     if (argc < 2) {
  310.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  311.         " option ?arg arg ...?\"", (char *) NULL);
  312.     return TCL_ERROR;
  313.     }
  314.     c = argv[1][0];
  315.     length = strlen(argv[1]);
  316.     if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) {
  317.     for (i = 2; i < argc; i++) {
  318.         hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[i]);
  319.         if (hPtr == NULL) {
  320.         return TCL_OK;
  321.         }
  322.         pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
  323.         Tcl_DeleteHashEntry(hPtr);
  324.         if (pkgPtr->version != NULL) {
  325.         ckfree(pkgPtr->version);
  326.         }
  327.         while (pkgPtr->availPtr != NULL) {
  328.         availPtr = pkgPtr->availPtr;
  329.         pkgPtr->availPtr = availPtr->nextPtr;
  330.         ckfree(availPtr->version);
  331.         Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
  332.         ckfree((char *) availPtr);
  333.         }
  334.         ckfree((char *) pkgPtr);
  335.     }
  336.     } else if ((c == 'i') && (strncmp(argv[1], "ifneeded", length) == 0)) {
  337.     if ((argc != 4) && (argc != 5)) {
  338.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  339.             " ifneeded package version ?script?\"", (char *) NULL);
  340.         return TCL_ERROR;
  341.     }
  342.     if (CheckVersion(interp, argv[3]) != TCL_OK) {
  343.         return TCL_ERROR;
  344.     }
  345.     if (argc == 4) {
  346.         hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
  347.         if (hPtr == NULL) {
  348.         return TCL_OK;
  349.         }
  350.         pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
  351.     } else {
  352.         pkgPtr = FindPackage(interp, argv[2]);
  353.     }
  354.     for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
  355.         prevPtr = availPtr, availPtr = availPtr->nextPtr) {
  356.         if (ComparePkgVersions(availPtr->version, argv[3], (int *) NULL)
  357.             == 0) {
  358.         if (argc == 4) {
  359.             Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
  360.             return TCL_OK;
  361.         }
  362.         Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
  363.         break;
  364.         }
  365.     }
  366.     if (argc == 4) {
  367.         return TCL_OK;
  368.     }
  369.     if (availPtr == NULL) {
  370.         availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
  371.         availPtr->version = ckalloc((unsigned) (strlen(argv[3]) + 1));
  372.         strcpy(availPtr->version, argv[3]);
  373.         if (prevPtr == NULL) {
  374.         availPtr->nextPtr = pkgPtr->availPtr;
  375.         pkgPtr->availPtr = availPtr;
  376.         } else {
  377.         availPtr->nextPtr = prevPtr->nextPtr;
  378.         prevPtr->nextPtr = availPtr;
  379.         }
  380.     }
  381.     availPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1));
  382.     strcpy(availPtr->script, argv[4]);
  383.     } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) {
  384.     if (argc != 2) {
  385.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  386.             " names\"", (char *) NULL);
  387.         return TCL_ERROR;
  388.     }
  389.     tablePtr = &iPtr->packageTable;
  390.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
  391.         hPtr = Tcl_NextHashEntry(&search)) {
  392.         pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
  393.         if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
  394.         Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
  395.         }
  396.     }
  397.     } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)) {
  398.     if ((argc != 3) && (argc != 4)) {
  399.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  400.             " provide package ?version?\"", (char *) NULL);
  401.         return TCL_ERROR;
  402.     }
  403.     if (argc == 3) {
  404.         hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
  405.         if (hPtr != NULL) {
  406.         pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
  407.         if (pkgPtr->version != NULL) {
  408.             Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
  409.         }
  410.         }
  411.         return TCL_OK;
  412.     }
  413.     if (CheckVersion(interp, argv[3]) != TCL_OK) {
  414.         return TCL_ERROR;
  415.     }
  416.     return Tcl_PkgProvide(interp, argv[2], argv[3]);
  417.     } else if ((c == 'r') && (strncmp(argv[1], "require", length) == 0)) {
  418.     if (argc < 3) {
  419.         requireSyntax:
  420.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  421.             " require ?-exact? package ?version?\"", (char *) NULL);
  422.         return TCL_ERROR;
  423.     }
  424.     if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) {
  425.         exact = 1;
  426.     } else {
  427.         exact = 0;
  428.     }
  429.     version = NULL;
  430.     if (argc == (4+exact)) {
  431.         version = argv[3+exact];
  432.         if (CheckVersion(interp, version) != TCL_OK) {
  433.         return TCL_ERROR;
  434.         }
  435.     } else if ((argc != 3) || exact) {
  436.         goto requireSyntax;
  437.     }
  438.     version = Tcl_PkgRequire(interp, argv[2+exact], version, exact);
  439.     if (version == NULL) {
  440.         return TCL_ERROR;
  441.     }
  442.     Tcl_SetResult(interp, version, TCL_VOLATILE);
  443.     } else if ((c == 'u') && (strncmp(argv[1], "unknown", length) == 0)) {
  444.     if (argc == 2) {
  445.         if (iPtr->packageUnknown != NULL) {
  446.         Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
  447.         }
  448.     } else if (argc == 3) {
  449.         if (iPtr->packageUnknown != NULL) {
  450.         ckfree(iPtr->packageUnknown);
  451.         }
  452.         if (argv[2][0] == 0) {
  453.         iPtr->packageUnknown = NULL;
  454.         } else {
  455.         iPtr->packageUnknown = (char *) ckalloc((unsigned)
  456.             (strlen(argv[2]) + 1));
  457.         strcpy(iPtr->packageUnknown, argv[2]);
  458.         }
  459.     } else {
  460.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  461.             " unknown ?command?\"", (char *) NULL);
  462.         return TCL_ERROR;
  463.     }
  464.     } else if ((c == 'v') && (strncmp(argv[1], "vcompare", length) == 0)
  465.         && (length >= 2)) {
  466.     if (argc != 4) {
  467.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  468.             " vcompare version1 version2\"", (char *) NULL);
  469.         return TCL_ERROR;
  470.     }
  471.     if ((CheckVersion(interp, argv[2]) != TCL_OK)
  472.         || (CheckVersion(interp, argv[3]) != TCL_OK)) {
  473.         return TCL_ERROR;
  474.     }
  475.     TclFormatInt(buf, ComparePkgVersions(argv[2], argv[3], (int *) NULL));
  476.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  477.     } else if ((c == 'v') && (strncmp(argv[1], "versions", length) == 0)
  478.         && (length >= 2)) {
  479.     if (argc != 3) {
  480.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  481.             " versions package\"", (char *) NULL);
  482.         return TCL_ERROR;
  483.     }
  484.     hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
  485.     if (hPtr != NULL) {
  486.         pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
  487.         for (availPtr = pkgPtr->availPtr; availPtr != NULL;
  488.             availPtr = availPtr->nextPtr) {
  489.         Tcl_AppendElement(interp, availPtr->version);
  490.         }
  491.     }
  492.     } else if ((c == 'v') && (strncmp(argv[1], "vsatisfies", length) == 0)
  493.         && (length >= 2)) {
  494.     if (argc != 4) {
  495.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  496.             " vsatisfies version1 version2\"", (char *) NULL);
  497.         return TCL_ERROR;
  498.     }
  499.     if ((CheckVersion(interp, argv[2]) != TCL_OK)
  500.         || (CheckVersion(interp, argv[3]) != TCL_OK)) {
  501.         return TCL_ERROR;
  502.     }
  503.     ComparePkgVersions(argv[2], argv[3], &satisfies);
  504.     TclFormatInt(buf, satisfies);
  505.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  506.     } else {
  507.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  508.         "\": should be forget, ifneeded, names, ",
  509.         "provide, require, unknown, vcompare, ",
  510.         "versions, or vsatisfies", (char *) NULL);
  511.     return TCL_ERROR;
  512.     }
  513.     return TCL_OK;
  514. }
  515.  
  516. /*
  517.  *----------------------------------------------------------------------
  518.  *
  519.  * FindPackage --
  520.  *
  521.  *    This procedure finds the Package record for a particular package
  522.  *    in a particular interpreter, creating a record if one doesn't
  523.  *    already exist.
  524.  *
  525.  * Results:
  526.  *    The return value is a pointer to the Package record for the
  527.  *    package.
  528.  *
  529.  * Side effects:
  530.  *    A new Package record may be created.
  531.  *
  532.  *----------------------------------------------------------------------
  533.  */
  534.  
  535. static Package *
  536. FindPackage(interp, name)
  537.     Tcl_Interp *interp;        /* Interpreter to use for package lookup. */
  538.     char *name;            /* Name of package to fine. */
  539. {
  540.     Interp *iPtr = (Interp *) interp;
  541.     Tcl_HashEntry *hPtr;
  542.     int new;
  543.     Package *pkgPtr;
  544.  
  545.     hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new);
  546.     if (new) {
  547.     pkgPtr = (Package *) ckalloc(sizeof(Package));
  548.     pkgPtr->version = NULL;
  549.     pkgPtr->availPtr = NULL;
  550.     Tcl_SetHashValue(hPtr, pkgPtr);
  551.     } else {
  552.     pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
  553.     }
  554.     return pkgPtr;
  555. }
  556.  
  557. /*
  558.  *----------------------------------------------------------------------
  559.  *
  560.  * TclFreePackageInfo --
  561.  *
  562.  *    This procedure is called during interpreter deletion to
  563.  *    free all of the package-related information for the
  564.  *    interpreter.
  565.  *
  566.  * Results:
  567.  *    None.
  568.  *
  569.  * Side effects:
  570.  *    Memory is freed.
  571.  *
  572.  *----------------------------------------------------------------------
  573.  */
  574.  
  575. void
  576. TclFreePackageInfo(iPtr)
  577.     Interp *iPtr;        /* Interpereter that is being deleted. */
  578. {
  579.     Package *pkgPtr;
  580.     Tcl_HashSearch search;
  581.     Tcl_HashEntry *hPtr;
  582.     PkgAvail *availPtr;
  583.  
  584.     for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
  585.         hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
  586.     pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
  587.     if (pkgPtr->version != NULL) {
  588.         ckfree(pkgPtr->version);
  589.     }
  590.     while (pkgPtr->availPtr != NULL) {
  591.         availPtr = pkgPtr->availPtr;
  592.         pkgPtr->availPtr = availPtr->nextPtr;
  593.         ckfree(availPtr->version);
  594.         Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
  595.         ckfree((char *) availPtr);
  596.     }
  597.     ckfree((char *) pkgPtr);
  598.     }
  599.     Tcl_DeleteHashTable(&iPtr->packageTable);
  600.     if (iPtr->packageUnknown != NULL) {
  601.     ckfree(iPtr->packageUnknown);
  602.     }
  603. }
  604.  
  605. /*
  606.  *----------------------------------------------------------------------
  607.  *
  608.  * CheckVersion --
  609.  *
  610.  *    This procedure checks to see whether a version number has
  611.  *    valid syntax.
  612.  *
  613.  * Results:
  614.  *    If string is a properly formed version number the TCL_OK
  615.  *    is returned.  Otherwise TCL_ERROR is returned and an error
  616.  *    message is left in interp->result.
  617.  *
  618.  * Side effects:
  619.  *    None.
  620.  *
  621.  *----------------------------------------------------------------------
  622.  */
  623.  
  624. static int
  625. CheckVersion(interp, string)
  626.     Tcl_Interp *interp;        /* Used for error reporting. */
  627.     char *string;        /* Supposedly a version number, which is
  628.                  * groups of decimal digits separated
  629.                  * by dots. */
  630. {
  631.     char *p = string;
  632.  
  633.     if (!isdigit(UCHAR(*p))) {
  634.     goto error;
  635.     }
  636.     for (p++; *p != 0; p++) {
  637.     if (!isdigit(UCHAR(*p)) && (*p != '.')) {
  638.         goto error;
  639.     }
  640.     }
  641.     if (p[-1] != '.') {
  642.     return TCL_OK;
  643.     }
  644.  
  645.     error:
  646.     Tcl_AppendResult(interp, "expected version number but got \"",
  647.         string, "\"", (char *) NULL);
  648.     return TCL_ERROR;
  649. }
  650.  
  651. /*
  652.  *----------------------------------------------------------------------
  653.  *
  654.  * ComparePkgVersions --
  655.  *
  656.  *    This procedure compares two version numbers.
  657.  *
  658.  * Results:
  659.  *    The return value is -1 if v1 is less than v2, 0 if the two
  660.  *    version numbers are the same, and 1 if v1 is greater than v2.
  661.  *    If *satPtr is non-NULL, the word it points to is filled in
  662.  *    with 1 if v2 >= v1 and both numbers have the same major number
  663.  *    or 0 otherwise.
  664.  *
  665.  * Side effects:
  666.  *    None.
  667.  *
  668.  *----------------------------------------------------------------------
  669.  */
  670.  
  671. static int
  672. ComparePkgVersions(v1, v2, satPtr)
  673.     char *v1, *v2;        /* Versions strings, of form 2.1.3 (any
  674.                  * number of version numbers). */
  675.     int *satPtr;        /* If non-null, the word pointed to is
  676.                  * filled in with a 0/1 value.  1 means
  677.                  * v1 "satisfies" v2:  v1 is greater than
  678.                  * or equal to v2 and both version numbers
  679.                  * have the same major number. */
  680. {
  681.     int thisIsMajor, n1, n2;
  682.  
  683.     /*
  684.      * Each iteration of the following loop processes one number from
  685.      * each string, terminated by a ".".  If those numbers don't match
  686.      * then the comparison is over;  otherwise, we loop back for the
  687.      * next number.
  688.      */
  689.  
  690.     thisIsMajor = 1;
  691.     while (1) {
  692.     /*
  693.      * Parse one decimal number from the front of each string.
  694.      */
  695.  
  696.     n1 = n2 = 0;
  697.     while ((*v1 != 0) && (*v1 != '.')) {
  698.         n1 = 10*n1 + (*v1 - '0');
  699.         v1++;
  700.     }
  701.     while ((*v2 != 0) && (*v2 != '.')) {
  702.         n2 = 10*n2 + (*v2 - '0');
  703.         v2++;
  704.     }
  705.  
  706.     /*
  707.      * Compare and go on to the next version number if the
  708.      * current numbers match.
  709.      */
  710.  
  711.     if (n1 != n2) {
  712.         break;
  713.     }
  714.     if (*v1 != 0) {
  715.         v1++;
  716.     } else if (*v2 == 0) {
  717.         break;
  718.     }
  719.     if (*v2 != 0) {
  720.         v2++;
  721.     }
  722.     thisIsMajor = 0;
  723.     }
  724.     if (satPtr != NULL) {
  725.     *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
  726.     }
  727.     if (n1 > n2) {
  728.     return 1;
  729.     } else if (n1 == n2) {
  730.     return 0;
  731.     } else {
  732.     return -1;
  733.     }
  734. }
  735.